COMMENT ⊗   VALID 00002 PAGES
C REC  PAGE   DESCRIPTION
C00001 00001
C00002 00002	(* $A+,D+*)
C00013 ENDMK
C⊗;
(* $A+,D+*)

program	PALINDROME(OUTPUT);

const	NUMMAX = 6; PALMAX = 100;  NUMLIM = 7; PALLIM = 101;
	TABMAX = 500;  TABLIM = 501;
	CLASSLIM = 6900; CLASSMAX = 6899;
	YEA = 262144; NIX = 134217728;
var I, J, K, L, N, NXTOT, TABL, NMAX, NMIN, DCLASS,
	 NUMVAL, CVAL, PALTOT, PALVAL, CARRY : integer;
    NUM : array [1..NUMLIM] of integer;
    PAL, PAL2 : array [1..PALLIM] of integer;
    TAB : array [0..TABLIM] of integer;
    CLASS : array [0..CLASSLIM] of integer;
    TEMP : array [1..5] of integer;

procedure OUTTEMP (K : integer);
    var I, J : integer;
    begin
    I := K;
    write(OUTPUT,'     ');
    for J := 1 to CVAL do
	begin
	TEMP[J] := I mod 19;
	I := I div 19;
	end;
    for J := CVAL downto 1 do
	write (OUTPUT,TEMP[J]:6);
    J := CLASS[K] mod YEA;
    write(OUTPUT,J:8);
    end;

procedure TYPTEMP (K : integer);
    var I, J : integer;
    begin
    I := K;
    for J := 1 to CVAL do
	begin
	TEMP[J] := I mod 19;
	I := I div 19;
	end;
    for J := CVAL downto 1 do
	write (TTY,TEMP[J]:4);
    write(TTY,'    ');
    end;

begin (* Main program*)
for I := 1 to NUMMAX do NUM[I] := 0;
NUM [6] := 1; NUMVAL := 6;		(* Initial conditions *)
writeln (OUTPUT,
	'  Palindrome formation tested to a maximum of',PALMAX:4,' digits');
writeln (OUTPUT);
while NUMVAL <= NUMMAX do
    begin (*while NUMVAL <= NUMMAX*)
    writeln (OUTPUT,'DATA FOR',NUMVAL:2,'-DIGIT DECIMAL NUMBERS');
    writeln(OUTPUT);
    writeln(TTY);
    writeln (TTY,'DATA FOR',NUMVAL:2,'-DIGIT DECIMAL NUMBERS'); BREAK;
    DCLASS := NUMVAL;
    CVAL := NUMVAL div 2 + NUMVAL mod 2;
    for I := 1 TO PALMAX do PAL[I] := 0;
    for I := 0 to CLASSMAX do CLASS[I] := 0;
    for I := 0 to TABMAX do TAB[I] := 0;    (* palindrome add data *)
    PALTOT := 0;                            (* Count of number of palindromes *)
    NXTOT := 0;                             (* Count of non-palindromes*)
    NMAX := 0;				    (* Maximum adds for a palindrome*)
    NMIN := 500;                            (* Minimun adds for intransigents *)
    while DCLASS = NUMVAL do 
	begin

	I := 1; J := NUMVAL; PALVAL := NUMVAL;
	while (NUM[I] = NUM[J]) and (I < J) DO
	    begin
	    I := I + 1;  J := J - 1;
	    end;
	if I >= J then
	    begin                   (* An initial palindrome *)
	    CLASS[0] := CLASS[0] + 1;       (* 0 CLASS reserved for initial pals*)
	    PALTOT := PALTOT + 1;
	    end
	else
	    begin                   (* Not a palindrome initially *)
	    K := 0;  I := 1; J := NUMVAL;
	    while I < J do
		begin               (* Compute CLASS value *)
		K := (K * 19) + NUM[I] + NUM[J];
		I := I + 1;  J := J -1;
		end;
	    if I = J then K := K * 19 + NUM[I];     (* NUMVAL odd, case*)
	    if CLASS[K] <> 0 then       (* Known class*)
		begin
		if CLASS[K] >= NIX then NXTOT := NXTOT + 1 
		    else PALTOT := PALTOT + 1;
		CLASS[K] := CLASS[K] + 1;
		end

	    else
		begin                       (* Not a known class*)



		N := 0;                         (* To count number of additions *)
		for I := 1 to NUMVAL do PAL[I] := NUM[I];
		for I := NUMVAL + 1 TO PALMAX do PAL[I] := 0;
		while PALVAL <= PALMAX do
		    begin                                   (* while PALVAL <= PALMAX*)
		    I := 1; J := PALVAL;
		    while ((PAL[I] = PAL [J]) and (I < J)) do
			begin
			I := I + 1;  J := J - 1;
			end;
		    if I >= J then
			begin
			CLASS[K] := N * YEA + 1;            (* start palindrome class*)
			if N > NMAX then NMAX := N;
			PALTOT := PALTOT + 1;
			PALVAL := PALMAX + 1;
			end
		    else                                   (* Still not a palindrome*)
			begin                               (* try another add*)
			J := PALVAL; CARRY := 0;
			for I := 1 to PALVAL do
			    begin                           (* Add numbers*)
			    PAL2[I] := PAL[I] + PAL[J] + CARRY;
			    if PAL2[I] > 9 then
				begin
				PAL2[I] := PAL2[I] - 10;  CARRY := 1;
				end
			    else CARRY := 0;
			    J := J - 1;
			    end;                            (* add numbers*)
			if CARRY = 1 then
			    begin
			    PALVAL := PALVAL +1; PAL2[PALVAL] := 1;
			    end;
			N := N + 1;
			if PALVAL = PALMAX + 1  then        (* Limit on depth*)
			    begin                           (* One to report*)
			    if N < NMIN then NMIN := N;
			    NXTOT := NXTOT + 1;  
			    CLASS[K] := NIX + 1;   (* Start INTRANSIGENT class*)
			    N := 0;         (* We are through with this N *)
			    TYPTEMP(K);
			    end                     (* of one to report*)
			else for I := 1 to PALVAL do PAL[I] := PAL2[I];
			end;
		    end                      (* while PALVAL <= PALMAX*);
		end;                        (* not a known class*)
	    end;                            (* not an initial palindrome*)
	CARRY := 1;
	for I := 1 to NUMVAL do
	    begin
	    NUM[I] := NUM[I] +CARRY;
	    if NUM[I] > 9 then
		begin
		NUM[I] := 0;
		CARRY := 1;
		end
	    else CARRY := 0;
	    end;
	if CARRY = 1 then 
	    begin
	    NUMVAL := NUMVAL +1;
	    NUM[NUMVAL] := 1;
	    end;
	end;                        (* While DCLASS = NUMVAL*)
    writeln (OUTPUT,NMAX:6,' MAX ADDS for',PALTOT:7,' PALINDROMES, with',
	    NXTOT:6,' INTRANSIGENT numbers');
    writeln(OUTPUT);
    writeln(TTY);
    writeln (TTY,NMAX:6,' MAX ADDS for',PALTOT:6,' PALINDROMES, with',
	    NXTOT:5,' INTRANSIGENT numbers'); BREAK;
    if NXTOT = 0 then writeln (OUTPUT,'           No intransigent numbers found') 
    else
	begin
	writeln(OUTPUT,'           Intrasigents by classes FOR',NMIN:4,' ADDS');
	writeln(OUTPUT);
	N := DCLASS div 2;
	for J := 1 TO 2 do
	    begin
	    write(OUTPUT,'      ');
	    for L := 1 to N do write (OUTPUT,'  SUM',L:1);
	    if (DCLASS MOD 2) = 1 then	write (OUTPUT,'  MID#');
	    write (OUTPUT,'  #FOUND');
	    end;
	    writeln (OUTPUT);
	end;
    L := 0;
    for I := 0 to CLASSMAX do
	begin
	if CLASS[I] <> 0 then
	    begin
	    if CLASS[I] < NIX then
		begin               (* Collect palindrome add data*)
		J := CLASS[I] div YEA;
		TAB[J] := TAB[J] + CLASS[I] mod YEA;
		end
	    else
		begin
		write(OUTPUT,' ');
		OUTTEMP(I);		(* Write out intransigent data*)
		L := L +1;
		if (L mod 2) = 0 then writeln(OUTPUT);
		end;
	    end;
	end;
    writeln(OUTPUT);
    J := 0;
    writeln(OUTPUT);
    writeln(OUTPUT,'           Palindromes Found WITH NUMBER OF ADDS');
    writeln(OUTPUT);
    writeln(OUTPUT,
	'       FOUND #ADDS     FOUND #ADDS     FOUND #ADDS     FOUND #ADDS');
    I := 0;
    for J := 0 to TABMAX do
	if TAB[J] <> 0 then
	    begin
	    write (OUTPUT,TAB[J]:12,J:4);
	    I := I + 1;
	    if (I mod 4) = 0 then writeln(OUTPUT);
	    end;
    writeln(OUTPUT);
    writeln(OUTPUT);


    end (*while NUMVAL <= NUMMAX*);
end.